home *** CD-ROM | disk | FTP | other *** search
/ Merciful 5 / Merciful - Disc 5.iso / software / p / pcqpascalv1.2d.lha / Examples2 / cal / cal.p < prev    next >
Text File  |  1997-05-06  |  24KB  |  899 lines
  1. Program Cal_v20;
  2.  
  3. {
  4.     cal v2.0
  5.     © 1995 by Andreas Tetzl
  6.     FREEWARE
  7. }
  8.  
  9. { /// ------------------------------ "Includes" ------------------------------ }
  10.  
  11. {$I "Include:Utility/Utility.i"}
  12. {$I "Include:Utility/Date.i"}
  13. {$I "Include:Exec/Libraries.i"}
  14. {$I "Include:Exec/Memory.i"}
  15. {$I "Include:Exec/Lists.i"}
  16. {$I "Include:Exec/Nodes.i"}
  17. {$I "Include:Exec/Tasks.i"}
  18. {$I "Include:Libraries/Locale.i"}
  19. {$I "Include:Utils/TimerUtils.i"}
  20. {$I "Include:Utils/StringLib.i"}
  21. {$I "Include:Utils/Parameters.i"}
  22. {$I "Include:Utils/Break.i"}
  23. {$I "Include:DOS/DOSExtens.i"}
  24. {$I "Include:DOS/RDArgs.i"}
  25.  
  26. { /// ------------------------------------------------------------------------ }
  27.  
  28. { /// -------------------------------- "VAR" --------------------------------- }
  29.  
  30. Type  DateStruct = Record
  31.         succ, pred : ^DateStruct;
  32.         day, month, year, color, bcolor : Integer;
  33.         bold, italics, underlined : Boolean;
  34.       end;
  35.       DateStructPtr = ^DateStruct;
  36.  
  37. const   spaces = "                    ";
  38.  
  39.     version = "$VER: cal v2.0 (05-Nov-95) by Andreas Tetzl";
  40.  
  41.     configfilename : Array[0..2] of String = (NIL,"cal.dates","s:cal.dates");
  42.  
  43. VAR Timer : TimeRequestPtr;
  44.     TV : TimeVal;
  45.     CD : ClockData;
  46.     amigadate, i, j : Integer;
  47.     mday : String;
  48.     Str : Array[1..9] of String;
  49.     posadd : Array[1..9] of Integer;
  50.     month, year : Integer;
  51.     SUNDAY_LAST, WHOLE_YEAR : Boolean;
  52.  
  53.     Dates : ListPtr;
  54.  
  55.     { Strings }
  56.     wdays_sunday_first,
  57.     wdays_sunday_last : String;
  58.     mon : Array[1..12] of String;
  59.     badnumber : String;
  60.  
  61. { /// ------------------------------------------------------------------------ }
  62.  
  63. { /// ----------------------- "FUNCTION My_NameFromFH" ----------------------- }
  64.  
  65. FUNCTION My_NameFromFH(a1, a2 : Address; a3 : Integer) : Boolean;
  66. BEGIN
  67.  {$A
  68.     XREF    _p%DOSBase
  69.     move.l  _p%DOSBase,a6
  70.     move.l  4(sp),d3
  71.     move.l  8(sp),d2
  72.     move.l  12(sp),d1
  73.     jsr     -408(a6)
  74.  }
  75. END;
  76.  
  77. { /// ------------------------------------------------------------------------ }
  78.  
  79. { /// ------------------------- "FUNCTION My_GetVar" ------------------------- }
  80.  
  81. FUNCTION My_GetVar(name, buf : Address; len, flags : Integer) : Integer;
  82. BEGIN
  83. {$A
  84.     XREF    _p%DOSBase
  85.     move.l  4(sp),d4
  86.     move.l  8(sp),d3
  87.     move.l  12(sp),d2
  88.     move.l  16(sp),d1
  89.     move.l  _p%DOSBase,a6
  90.     jsr     -906(a6)
  91. }
  92. END;
  93.  
  94. { /// ------------------------------------------------------------------------ }
  95.  
  96. { /// ------------------------- "PROCEDURE FreeList" ------------------------- }
  97.  
  98. PROCEDURE FreeList(L : ListPtr);
  99. { free the list }
  100. VAR MyNode, ThisNode : DateStructPtr;
  101. BEGIN
  102.   MyNode:=DateStructPtr(L^.lh_head);
  103.   While MyNode^.succ<>NIL do
  104.    BEGIN
  105.     ThisNode:=MyNode;
  106.     MyNode:=MyNode^.succ;
  107.     Dispose(ThisNode);
  108.    END;
  109.   Dispose(L);
  110. END;
  111.  
  112. { /// ------------------------------------------------------------------------ }
  113.  
  114. { /// ------------------------ "PROCEDURE CleanExit" ------------------------- }
  115.  
  116. PROCEDURE CleanExit(Why : String; RC : Integer);
  117. BEGIN
  118.   FreeList(Dates);
  119.   If Timer<>NIL then DeleteTimer(Timer);
  120.   If UtilityBase<>NIL then CloseLibrary(UtilityBase);
  121.   If Why<>NIL then Writeln(Why);
  122.   Exit(RC);
  123. END;
  124.  
  125. { /// ------------------------------------------------------------------------ }
  126.  
  127. { /// --------------------------- "FUNCTION leap" ---------------------------- }
  128.  
  129. FUNCTION leap(year : Integer) : Boolean;
  130. { TRUE for leap year, FALSE otherwise }
  131. BEGIN
  132.  if (year mod 4=0) and NOT((year>1582) and (year mod 100=0) and (year mod 400<>0)) then
  133.   leap:=TRUE
  134.  else
  135.   leap:=FALSE;
  136. END;
  137.  
  138. { /// ------------------------------------------------------------------------ }
  139.  
  140. { /// --------------------------- "FUNCTION days" ---------------------------- }
  141.  
  142. FUNCTION days(year, month : Integer) : Integer;
  143. { return number of days in the given month }
  144. const day  : Array[1..12] of Integer = (
  145.                     31,28,31,30,31,30,
  146.                     31,31,30,31,30,31);
  147. BEGIN
  148.   if (month=2) and (leap(year)) then days:=day[month]+1
  149.                                 else days:=day[month];
  150.  
  151. END;
  152.  
  153. { /// ------------------------------------------------------------------------ }
  154.  
  155. { /// ------------------------- "FUNCTION AddNode" -------------------------- }
  156.  
  157. FUNCTION AddNode(day, month, year, color, bcolor : Integer; bold, italics, underl : Boolean) : Boolean;
  158. { add an element to the list of dates to be highlighted }
  159. VAR MyNode : DateStructPtr;
  160. BEGIN
  161. {
  162.   Writeln(year,"-",month,"-",day);
  163.   Writeln(color," ",Integer(bold)," ",Integer(italics)," ",Integer(underl));
  164.   Writeln;
  165. }
  166.   if (year>3000) or (month>12) or (day>days(year,month)) or (day<1) then AddNode:=FALSE;
  167.   if (year=1582) and (month=10) and (day>4) and (day<15) then AddNode:=FALSE;
  168.  
  169.   New(MyNode);
  170.   MyNode^.day:=day;
  171.   MyNode^.month:=month;
  172.   MyNode^.year:=year;
  173.   MyNode^.color:=color;
  174.   MyNode^.bcolor:=bcolor;
  175.   MyNode^.bold:=bold;
  176.   MyNode^.italics:=italics;
  177.   MyNode^.underlined:=underl;
  178.   AddTail(Dates,NodePtr(MyNode));
  179.   AddNode:=TRUE;
  180. END;
  181.  
  182. { /// ------------------------------------------------------------------------ }
  183.  
  184. { /// ------------------------ "PROCEDURE ReadConfig" ------------------------ }
  185.  
  186. PROCEDURE ReadConfig;
  187. { parse s:cal.dates
  188.   call AddNode for each entry }
  189.  
  190. VAR FH : FileHandle;
  191.     line, Str : String;
  192.     c, c2 : Char;
  193.     i, j, l : Integer;
  194.     year, month, day, color, bcolor : Integer;
  195.     bold, italics, underl : Boolean;
  196. BEGIN
  197.   l:=0;
  198.   line:=AllocString(100);
  199.   Str:=AllocString(100);
  200.  
  201.   FH:=NIL;
  202.   if NOT StrEq(configfilename[0],"") then FH:=DOSOpen(configfilename[0],MODE_OLDFILE);
  203.   if FH=NIL then FH:=DOSOpen(configfilename[1],MODE_OLDFILE);
  204.   if FH=NIL then FH:=DOSOpen(configfilename[2],MODE_OLDFILE);
  205.   if FH=NIL then Return;
  206.  
  207.   While FGets(FH,line,100)<>NIL do
  208.    BEGIN
  209.     Inc(l);
  210.     i:=0;
  211.     While isspace(line[i]) do Inc(i);
  212.  
  213.     if (line[0]<>'\0') and (line[0]<>'\n') and (line[0]<>';') and (line[i]<>';') then
  214.      BEGIN
  215.       bold:=FALSE; italics:=FALSE; underl:=FALSE; color:=-1; bcolor:=-1;
  216.       year:=0; month:=0; day:=0;
  217.  
  218.       i:=0;
  219.       While isspace(line[i]) do Inc(i);
  220.       if (isdigit(line[i])) or (line[i]='?') then    { detected a date }
  221.        BEGIN
  222.         StrCpy(Str,"");
  223.         While (isdigit(line[i])) or (line[i]='?') do
  224.          BEGIN
  225.           StrnCat(Str,adr(line[i]),1); { copy year }
  226.           Inc(i);
  227.          END;
  228.         j:=StrToLong(Str,adr(year));
  229.         Inc(i);  { - or / }
  230.  
  231.         StrCpy(Str,"");
  232.         While (isdigit(line[i])) or (line[i]='?') do
  233.          BEGIN
  234.           StrnCat(Str,adr(line[i]),1); { copy month }
  235.           Inc(i);
  236.          END;
  237.         j:=StrToLong(Str,adr(month));
  238.         Inc(i);  { - or / }
  239.  
  240.         StrCpy(Str,"");
  241.         While isdigit(line[i]) do   { don't allow '?' for day }
  242.          BEGIN
  243.           StrnCat(Str,adr(line[i]),1); { copy day }
  244.           Inc(i);
  245.          END;
  246.         j:=StrToLong(Str,adr(day));
  247.        END;
  248.  
  249.       Dec(i);
  250.       Repeat
  251.        Inc(i);
  252.        While isspace(line[i]) do Inc(i);
  253.        c:=line[i]; c2:=line[i+1];
  254.        While isalnum(line[i]) do Inc(i);
  255.        Case toupper(c) of
  256.         'B' : bold:=TRUE;
  257.         'I' : italics:=TRUE;
  258.         'U' : underl:=TRUE;
  259.         'C' : color:=ord(c2)-48;
  260.         'R' : bcolor:=ord(c2)-48;
  261.        END;
  262.       Until (line[i]='\n') or (line[i]='\0') or (line[i]=';');
  263.       if ((day=0) and (month=0) and (year=0)) or
  264.          ((color=-1) and (bcolor=-1) and (bold=FALSE) and (italics=FALSE) and (underl=FALSE)) then
  265.        BEGIN
  266.         If My_NameFromFH(FH,Str,100) then;
  267.         DOSClose(FH);
  268.         Writeln("syntax error in line ",l," of ",Str);
  269.         FreeList(Dates);
  270.         New(Dates);
  271.         NewList(Dates); { create empty list }
  272.         Return;
  273.        END
  274.        ELSE
  275.         if NOT AddNode(day,month,year,color,bcolor,bold,italics,underl) then
  276.          BEGIN
  277.           If My_NameFromFH(FH,Str,100) then;
  278.           DOSClose(FH);
  279.           Writeln("invalid date in line ",l," of ",Str);
  280.           FreeList(Dates);
  281.           New(Dates);
  282.           NewList(Dates); { create empty list }
  283.           Return;
  284.          END;
  285.      END;
  286.    END;
  287.  
  288.   DOSClose(FH);
  289. END;
  290.  
  291. { /// ------------------------------------------------------------------------ }
  292.  
  293. { /// -------------------------- "PROCEDURE ReadENV" -------------------------- }
  294.  
  295. PROCEDURE ReadENV;
  296. { read ENV:SUNDAY_LAST
  297.   if it does'nt exists, don't change the boolean var
  298. }
  299. VAR Str : String;
  300.     Mypr : ProcessPtr;
  301.     OldWin : Address;
  302. BEGIN
  303.   Str:=AllocString(10);
  304.  
  305.   MyPr:=ProcessPtr(FindTask(NIL));
  306.   OldWin:=MyPr^.pr_WindowPtr;
  307.   MyPr^.pr_WindowPtr:=address(-1);  { disable "please insert" requesters }
  308.  
  309.   if My_GetVar("SUNDAY_LAST",Str,2,0)<>-1 then
  310.    if Str[0]='1' then SUNDAY_LAST:=TRUE
  311.                  else SUNDAY_LAST:=FALSE;
  312.  
  313.   MyPr^.pr_WindowPtr:=OldWin;   { allow error requesters }
  314. end;
  315.  
  316. { /// ------------------------------------------------------------------------ }
  317.  
  318. { /// ----------------------- "PROCEDURE Init" ------------------------ }
  319.  
  320. PROCEDURE Init;
  321. { initialize all strings, use locale.library if possible }
  322. VAR i : Integer;
  323.     loc : LocalePtr;
  324.     cat : CatalogPtr;
  325.     Str : String;
  326. BEGIN
  327.   Str:=AllocString(30);
  328.   wdays_sunday_first:=AllocString(20);
  329.   wdays_sunday_last:=AllocString(20);
  330.   badnumber:=AllocString(30);
  331.   configfilename[0]:=AllocString(200);
  332.   For i:=1 to 12 do
  333.    mon[i]:=AllocString(20);
  334.  
  335.   StrCpy(wdays_sunday_first,"Su Mo Tu We Th Fr Sa");
  336.   StrCpy(wdays_sunday_last,"Mo Tu We Th Fr Sa Su");
  337.   StrCpy(mon[1],"January");
  338.   StrCpy(mon[2],"February");
  339.   StrCpy(mon[3],"March");
  340.   StrCpy(mon[4],"April");
  341.   StrCpy(mon[5],"May");
  342.   StrCpy(mon[6],"June");
  343.   StrCpy(mon[7],"July");
  344.   StrCpy(mon[8],"August");
  345.   StrCpy(mon[9],"September");
  346.   StrCpy(mon[10],"October");
  347.   StrCpy(mon[11],"November");
  348.   StrCpy(mon[12],"December");
  349.   StrCpy(badnumber,"bad number");
  350.  
  351.   LocaleBase:=OpenLibrary("locale.library",38);
  352.   if LocaleBase=NIL then Return;
  353.  
  354.   loc:=OpenLocale(NIL);
  355.   if loc=NIL then
  356.    BEGIN
  357.     CloseLibrary(localebase);
  358.     Return;
  359.    END;
  360.  
  361.   If loc^.loc_CalendarType=CT_7MON then SUNDAY_LAST:=TRUE else SUNDAY_LAST:=FALSE;
  362.  
  363.   StrnCpy(wdays_sunday_first,GetLocaleStr(loc,ABDAY_1),2);
  364.   StrCat(wdays_sunday_first," ");
  365.   StrnCat(wdays_sunday_first,GetLocaleStr(loc,ABDAY_2),2);
  366.   StrCat(wdays_sunday_first," ");
  367.   StrnCat(wdays_sunday_first,GetLocaleStr(loc,ABDAY_3),2);
  368.   StrCat(wdays_sunday_first," ");
  369.   StrnCat(wdays_sunday_first,GetLocaleStr(loc,ABDAY_4),2);
  370.   StrCat(wdays_sunday_first," ");
  371.   StrnCat(wdays_sunday_first,GetLocaleStr(loc,ABDAY_5),2);
  372.   StrCat(wdays_sunday_first," ");
  373.   StrnCat(wdays_sunday_first,GetLocaleStr(loc,ABDAY_6),2);
  374.   StrCat(wdays_sunday_first," ");
  375.   StrnCat(wdays_sunday_first,GetLocaleStr(loc,ABDAY_7),2);
  376.   StrCat(wdays_sunday_first," ");
  377.  
  378.   StrnCpy(wdays_sunday_last,GetLocaleStr(loc,ABDAY_2),2);
  379.   StrCat(wdays_sunday_last," ");
  380.   StrnCat(wdays_sunday_last,GetLocaleStr(loc,ABDAY_3),2);
  381.   StrCat(wdays_sunday_last," ");
  382.   StrnCat(wdays_sunday_last,GetLocaleStr(loc,ABDAY_4),2);
  383.   StrCat(wdays_sunday_last," ");
  384.   StrnCat(wdays_sunday_last,GetLocaleStr(loc,ABDAY_5),2);
  385.   StrCat(wdays_sunday_last," ");
  386.   StrnCat(wdays_sunday_last,GetLocaleStr(loc,ABDAY_6),2);
  387.   StrCat(wdays_sunday_last," ");
  388.   StrnCat(wdays_sunday_last,GetLocaleStr(loc,ABDAY_7),2);
  389.   StrCat(wdays_sunday_last," ");
  390.   StrnCat(wdays_sunday_last,GetLocaleStr(loc,ABDAY_1),2);
  391.   StrCat(wdays_sunday_last," ");
  392.  
  393.   StrCpy(mon[1],GetLocaleStr(loc,MON_1));
  394.   StrCpy(mon[2],GetLocaleStr(loc,MON_2));
  395.   StrCpy(mon[3],GetLocaleStr(loc,MON_3));
  396.   StrCpy(mon[4],GetLocaleStr(loc,MON_4));
  397.   StrCpy(mon[5],GetLocaleStr(loc,MON_5));
  398.   StrCpy(mon[6],GetLocaleStr(loc,MON_6));
  399.   StrCpy(mon[7],GetLocaleStr(loc,MON_7));
  400.   StrCpy(mon[8],GetLocaleStr(loc,MON_8));
  401.   StrCpy(mon[9],GetLocaleStr(loc,MON_9));
  402.   StrCpy(mon[10],GetLocaleStr(loc,MON_10));
  403.   StrCpy(mon[11],GetLocaleStr(loc,MON_11));
  404.   StrCpy(mon[12],GetLocaleStr(loc,MON_12));
  405.  
  406.  
  407.   cat:=OpenCatalogA(loc,"sys/dos.catalog",NIL);
  408.   if cat<>NIL then
  409.    BEGIN
  410.     badnumber:=GetCatalogStr(cat,115,"bad number"); { get localized "bad number" from dos.catalog }
  411.     CloseCatalog(cat);
  412.    END;
  413.  
  414.   CloseLocale(loc);
  415.   CloseLibrary(LocaleBase);
  416. END;
  417.  
  418. { /// ------------------------------------------------------------------------ }
  419.  
  420. { /// ----------------------- "PROCEDURE InsertString" ----------------------- }
  421.  
  422. PROCEDURE InsertString(s, ins : String; pos, l : Integer);
  423. { insert a string into another one at the given position
  424. }
  425.  
  426. VAR Str : String;
  427.     i, j : Integer;
  428. BEGIN
  429.   j:=0;
  430.   For i:=0 to Strlen(s) do
  431.    BEGIN
  432.     if s[i]='\e' then
  433.      BEGIN
  434.       if (s[i+2]='0') and (s[i+3]='m') then Inc(pos,4)
  435.       else
  436.       if (s[i+2]='1') and (s[i+3]='m') then Inc(pos,4)
  437.       else
  438.       if (s[i+2]='3') and (s[i+3]='m') then Inc(pos,4)
  439.       else
  440.       if (s[i+2]='4') and (s[i+3]='m') then Inc(pos,4)
  441.       else
  442.       if (s[i+2]='3') and (isdigit(s[i+3])) and (s[i+4]='m') then Inc(pos,5)
  443.       else
  444.       if (s[i+2]='4') and (isdigit(s[i+3])) and (s[i+4]='m') then Inc(pos,5);
  445.      END;
  446.    END;
  447.  
  448.   Str:=AllocString(255);
  449.   if pos>0 then StrnCpy(Str,s,pos);
  450.   StrCat(Str,ins);
  451.   StrCat(Str,adr(s[pos]));
  452.   StrCpy(s,spaces);
  453.   StrCpy(s,Str);
  454.   FreeString(Str);
  455.  
  456.   posadd[l]:=0;
  457.   For i:=0 to Strlen(s) do
  458.    BEGIN
  459.     if s[i]='\e' then
  460.      BEGIN
  461.       if (s[i+2]='0') and (s[i+3]='m') then Inc(posadd[l],4)
  462.       else
  463.       if (s[i+2]='1') and (s[i+3]='m') then Inc(posadd[l],4)
  464.       else
  465.       if (s[i+2]='3') and (s[i+3]='m') then Inc(posadd[l],4)
  466.       else
  467.       if (s[i+2]='4') and (s[i+3]='m') then Inc(posadd[l],4)
  468.       else
  469.       if (s[i+2]='3') and (isdigit(s[i+3])) and (s[i+4]='m') then Inc(posadd[l],5)
  470.       else
  471.       if (s[i+2]='4') and (isdigit(s[i+3])) and (s[i+4]='m') then Inc(posadd[l],5);
  472.      END;
  473.    END;
  474. END;
  475.  
  476. { /// ------------------------------------------------------------------------ }
  477.  
  478. { /// ------------------------ "PROCEDURE Highlight" ------------------------- }
  479.  
  480. PROCEDURE Highlight(s : String; d : DateStructPtr; l : Integer);
  481. { interprete highlighting-list-entry and insert ansi-sequence }
  482. const
  483.   Bold    = "\e[1m";
  484.   Italics = "\e[3m";
  485.   Underl  = "\e[4m";
  486.  
  487. VAR ESC, Str : String;
  488. BEGIN
  489.   ESC:=AllocString(255);
  490.   Str:=AllocString(10);
  491.   StrCpy(ESC,"");
  492.  
  493.   if d^.bold then StrCat(ESC,Bold);
  494.   if d^.italics then StrCat(ESC,Italics);
  495.   if d^.underlined then StrCat(ESC,Underl);
  496.   if d^.color<>-1 then
  497.    BEGIN
  498.     StrCat(ESC,"\e[3");
  499.     i:=IntToStr(Str,d^.color);
  500.     StrCat(ESC,Str);
  501.     StrCat(ESC,"m");
  502.    END;
  503.   if d^.bcolor<>-1 then
  504.    BEGIN
  505.     StrCat(ESC,"\e[4");
  506.     i:=IntToStr(Str,d^.bcolor);
  507.     StrCat(ESC,Str);
  508.     StrCat(ESC,"m");
  509.    END;
  510.  
  511.   StrCpy(s,ESC);
  512. END;
  513.  
  514. { /// ------------------------------------------------------------------------ }
  515.  
  516. { /// ----------------------- "FUNCTION My_Date2Amiga" ------------------------ }
  517.  
  518. FUNCTION My_Date2Amiga(date : ClockDataPtr) : Integer;
  519.  
  520. { calculate days (!) from 1-Jan-1 to the given date }
  521.  
  522. const days : Array[1..12] of Integer = (
  523.                     31,28,31,30,31,30,
  524.                     31,31,30,31,30,31);
  525.  
  526. years : Array[0..59] of Integer =
  527.  (0, 18262, 36525, 54787, 73050, 91312, 109575, 127837, 146100,
  528.  164362, 182625, 200887, 219150, 237412, 255675, 273937, 292200,
  529.  310462, 328725, 346987, 365250, 383512, 401775, 420037, 438300,
  530.  456562, 474825, 493087, 511350, 529612, 547875, 566137, 584389,
  531.  602651, 620913, 639175, 657437, 675699, 693961, 712223, 730486,
  532.  748748, 767010, 785272, 803534, 821796, 840058, 858320, 876583,
  533.  894845, 913107, 931369, 949631, 967893, 986155, 1004417, 1022680,
  534.  1040942, 1059204, 1077466);
  535.  
  536.  
  537. VAR amigatime, i, j, l, y : Integer;
  538. BEGIN
  539.   y:=(date^.year div 50)*50;
  540.   if date^.year div 50=date^.year/50 then Dec(y,50);
  541.   amigatime:=years[y div 50];
  542.  
  543.   For i:=y+1 to date^.year-1 do
  544.    BEGIN
  545.     if (i=1582) then Dec(amigatime,11);  { julian -> gregorian calendar }
  546.  
  547.     if leap(i) then Inc(amigatime,366)
  548.                else Inc(amigatime,365);
  549.    END;
  550.  
  551.   For i:=1 to date^.month-1 do
  552.    BEGIN
  553.     l:=days[i];
  554.     if (i=2) and (leap(date^.year)) then Inc(l,1);
  555.     For j:=1 to l do
  556.      Inc(amigatime,1);
  557.    END;
  558.  
  559.   For i:=1 to date^.mday-1 do Inc(amigatime,1);
  560.  
  561.   My_Date2Amiga:=amigatime;
  562. END;
  563.  
  564. { /// ------------------------------------------------------------------------ }
  565.  
  566. { /// ------------------------- "FUNCTION Shiftwday" ------------------------- }
  567.  
  568. FUNCTION Shiftwday(wday, pos : Integer) : Integer;
  569. { rotate weekday
  570.   Saturday->Sunday
  571.   Sunday->Monday
  572.   ...
  573. }
  574. VAR i : Integer;
  575. BEGIN
  576.   if pos=0 then Shiftwday:=wday;
  577.   If pos>0 then
  578.    For i:=1 to pos do
  579.     BEGIN
  580.      Inc(wday);
  581.      if wday=7 then wday:=0;
  582.     END
  583.   else
  584.    For i:=-1 downto pos do
  585.     BEGIN
  586.      Dec(wday);
  587.      if wday=-1 then wday:=6;
  588.     END;
  589.  
  590.   Shiftwday:=wday;
  591. END;
  592.  
  593. { /// ------------------------------------------------------------------------ }
  594.  
  595. { /// -------------------------- "FUNCTION weekday" -------------------------- }
  596.  
  597. FUNCTION weekday(year, month, day : Integer) : Integer;
  598. { return the weekday of the given date }
  599. VAR CD : ClockData;
  600.     wday : Integer;
  601. BEGIN
  602.   if amigadate=0 then
  603.    BEGIN
  604.     CD.year:=year;
  605.     CD.month:=month;
  606.     CD.mday:=day;
  607.     amigadate:=My_Date2Amiga(adr(CD));
  608.    END
  609.   ELSE Inc(amigadate);
  610.  
  611.   if (year<1582) or ((year=1582) and (month<10)) or ((year=1582) and (month=10) and (day<=4)) then
  612.    wday:=((amigadate+6) mod 7)
  613.   else
  614.    wday:=((amigadate-7) mod 7);
  615.  
  616.   { julian -> gregorian }
  617.  
  618.   if (year=1582) and (month=10) and (day>=5) and (day<15) then
  619.    wday:=5;
  620.  
  621.   if (year=1582) and (((month=10) and (day>14)) or (month>10)) then wday:=Shiftwday(wday,3);
  622.  
  623.   weekday:=wday;
  624. END;
  625.  
  626. { /// ------------------------------------------------------------------------ }
  627.  
  628. { /// ------------------------- "FUNCTION DateMatch" ------------------------- }
  629.  
  630. FUNCTION DateMatch(year, month, day : Integer) : DateStructPtr;
  631. { parse hightlighting-list and return entry-ptr if match }
  632. VAR d : DateStructPtr;
  633. BEGIN
  634.   d:=DateStructPtr(dates^.lh_head);
  635.   While d^.succ<>NIL do
  636.    BEGIN
  637.     if ((d^.year=0) or (year=d^.year)) and
  638.        ((d^.month=0) or (month=d^.month)) and
  639.        (day=d^.day) then DateMatch:=d;
  640.     d:=d^.succ;
  641.    END;
  642.  
  643.   DateMatch:=NIL;
  644. END;
  645.  
  646. { /// ------------------------------------------------------------------------ }
  647.  
  648. { /// --------------------- "PROCEDURE Cal" ------------------------------- }
  649.  
  650. PROCEDURE Cal(x : WORD);
  651. { create calendar with sunday last }
  652. VAR l, j, i, k, n, wday : Integer;
  653.     y, s, s2 : String;
  654.  
  655.     MyDS : DateStructPtr;
  656.  
  657. BEGIN
  658.   amigadate:=0;
  659.   y:=AllocString(40);
  660.   s:=AllocString(40);
  661.   s2:=AllocString(40);
  662.  
  663.   For i:=1 to 9 do
  664.    For j:=0 to x+19 do
  665.     if Str[i][j]='\0' then Str[i][j]:=' ';
  666.  
  667.   StrCpy(y,"");
  668.   For i:=1 to 7-(StrLen(mon[CD.month]) div 2) do StrCat(y," ");
  669.   If WHOLE_YEAR=TRUE then StrCat(y,"  ");
  670.   StrCpy(adr(Str[1][x]),y);
  671.   StrCat(Str[1],mon[CD.month]);
  672.   StrCat(Str[1]," ");
  673.   i:=IntToStr(y,CD.year);
  674.   if WHOLE_YEAR=FALSE then StrCat(Str[1],y);
  675.  
  676.   If SUNDAY_LAST then
  677.    StrCpy(adr(Str[2][x]),wdays_sunday_last)
  678.   else
  679.    StrCpy(adr(Str[2][x]),wdays_sunday_first);
  680.  
  681.   l:=3;
  682.  
  683.   CD.mday:=1;
  684.   For k:=1 to days(CD.year,CD.month) do
  685.    BEGIN
  686.     i:=IntToStr(mday,CD.mday);
  687.     if Strlen(mday)=1 then
  688.      BEGIN
  689.       mday[1]:=mday[0];
  690.       mday[0]:='0';
  691.       mday[2]:='\0';
  692.      END;
  693.  
  694.     wday:=weekday(CD.year,CD.month,CD.mday);
  695.     MyDS:=DateMatch(CD.year,CD.month,CD.mday);
  696.  
  697.     If SUNDAY_LAST=TRUE then
  698.      Case wday of
  699.       1 : n:=0;
  700.       2 : n:=3;
  701.       3 : n:=6;
  702.       4 : n:=9;
  703.       5 : n:=12;
  704.       6 : n:=15;
  705.       0 : n:=18;
  706.      end
  707.     else
  708.      Case wday of
  709.       0 : n:=0;
  710.       1 : n:=3;
  711.       2 : n:=6;
  712.       3 : n:=9;
  713.       4 : n:=12;
  714.       5 : n:=15;
  715.       6 : n:=18;
  716.      end;
  717.  
  718.     If MyDS<>NIL then
  719.      BEGIN
  720.       StrCpy(s,"  \0");
  721.       StrCpy(s2,"");
  722.       s[1]:=mday[1];
  723.       if mday[0]<>'0' then s[0]:=mday[0];
  724.       Highlight(s2,MyDS,l);
  725.       StrCat(s2,s);
  726.       StrCat(s2,"\e[0m");
  727.       InsertString(Str[l],s2,x+n,l);
  728.      END
  729.     ELSE
  730.      BEGIN
  731.       Str[l][x+posadd[l]+n+1]:=mday[1];
  732.       if mday[0]<>'0' then Str[l][x+posadd[l]+n]:=mday[0];
  733.      END;
  734.  
  735.     if ((SUNDAY_LAST=TRUE) and (wday=0)) or
  736.        ((SUNDAY_LAST=FALSE) and (wday=6)) then Inc(l);
  737.     Inc(CD.mday);
  738.   end;
  739.  
  740.   Inc(CD.month);
  741. END;           
  742.  
  743. { /// ------------------------------------------------------------------------ }
  744.  
  745. { /// ------------------------- "PROCEDURE Cal_YEAR" ------------------------- }
  746.  
  747. PROCEDURE Cal_YEAR;
  748. { create a calendar for a whole year }
  749. VAR j, i : Integer;
  750. BEGIN
  751.   CD.month:=1;
  752.  
  753.   For j:=1 to 4 do
  754.    BEGIN
  755.     For i:=1 to 9 do
  756.      BEGIN
  757.       StrCpy(Str[i],"                                                                                                                                 ");
  758.       posadd[i]:=0;
  759.      END;
  760.  
  761.     Cal(0); Cal(23); Cal(46);
  762.  
  763.     For i:=1 to 9 do
  764.      BEGIN
  765.       j:=Strlen(Str[i])-1;
  766.       While isspace(Str[i][j]) do
  767.        BEGIN                         { cut spaces }
  768.         Str[i][j]:='\0';
  769.         Dec(j);
  770.        END;
  771.       if StrLen(Str[i])>0 then Writeln(Str[i]);
  772.       If CheckBreak then CleanExit("*** break",0);
  773.      END;
  774.     Writeln;
  775.    END;
  776. END;
  777.  
  778. { /// ------------------------------------------------------------------------ }
  779.  
  780. { /// ------------------------- "PROCEDURE GetArgs" -------------------------- }
  781.  
  782. PROCEDURE GetArgs;
  783. { read arguments from command line }
  784.  
  785. const template = "MONTH/N,YEAR/N,Y/S,DATES/K";
  786.       ExtHelp = "\ncal v2.0 © 1995 by Andreas Tetzl\n\nMONTH  : specify month of year (1..12, default: current month)\nYEAR   : specify year (1..3000, default: current year)\nY      : show calendar of a whole year (default: off)\nDATES  : specify config-filename (default: s:cal.dates)\n\n";
  787.  
  788. VAR rda : RDArgsPtr;
  789.     vec : Array[0..3] of Address;
  790.  
  791. BEGIN
  792.   vec[0]:=NIL;
  793.   vec[1]:=NIL;
  794.   vec[2]:=NIL;
  795.   vec[3]:=NIL;
  796.  
  797.   rda:=AllocDosObject(DOS_RDARGS,NIL);
  798.   if rda=NIL then CleanExit(NIL,20);
  799.  
  800.   rda^.RDA_ExtHelp:=ExtHelp;
  801.  
  802.   if ReadArgs(template,adr(vec),rda)=NIL then
  803.    BEGIN
  804.     If Printfault(IoErr,NIL) then;
  805.     FreeDosObject(DOS_RDARGS,rda);
  806.     CleanExit(NIL,0);
  807.    END;
  808.  
  809.   year:=0;
  810.   month:=0;
  811.  
  812.   if vec[0]<>NIL then CopyMem(vec[0],adr(month),4);
  813.   if vec[1]<>NIL then CopyMem(vec[1],adr(year),4);
  814.   WHOLE_YEAR:=Boolean(vec[2]);
  815.   if vec[3]<>NIL then StrCpy(configfilename[0],vec[3]);
  816.  
  817.   FreeArgs(rda);
  818.   FreeDosObject(DOS_RDARGS,rda);
  819.  
  820.   if year=-1 then year:=-2;
  821.   if month=-1 then month:=-2;
  822.  
  823.   if (WHOLE_YEAR) and (year=0) then
  824.    BEGIN
  825.     year:=month;
  826.     month:=-1;
  827.    END;
  828.  
  829.   if (year=0) and (month>13) then
  830.    BEGIN
  831.     year:=month;
  832.     month:=-1;
  833.     WHOLE_YEAR:=TRUE;
  834.    END;
  835.  
  836.   if year=0 then year:=-1;
  837.   if month=0 then month:=-1;
  838. END;
  839.  
  840. { /// ------------------------------------------------------------------------ }
  841.  
  842. { /// -------------------------------- "Main" -------------------------------- }
  843.  
  844. BEGIN
  845.   For i:=1 to 9 do Str[i]:=AllocString(1000);
  846.   mday:=AllocString(10);
  847.  
  848.   New(Dates);
  849.   NewList(Dates);
  850.  
  851.   UtilityBase:=OpenLibrary("utility.library",37);
  852.   if UtilityBase=NIL then CleanExit("this program needs Kickstart 2.0 V37+",10);
  853.  
  854.   Timer:=CreateTimer(UNIT_VBLANK);
  855.   If Timer=NIL then CleanExit("could not open timer.device",10);
  856.  
  857.   Init;
  858.   GetArgs;
  859.   ReadENV;  { if env-variable exists, overwrite locale settings }
  860.  
  861.   GetSysTime(Timer,TV);
  862.   Amiga2Date(TV.tv_Secs,adr(CD));
  863.  
  864.   if ((month<>-1) and (month<1)) or (month>12) or ((year<1) and (year<>-1)) or (year>3000) then
  865.    CleanExit(badnumber,10);
  866.  
  867.   ReadConfig;
  868.  
  869.   if year<>-1 then CD.year:=year;
  870.   if month<>-1 then CD.month:=month;
  871.  
  872.   if WHOLE_YEAR then
  873.    BEGIN
  874.     Writeln("                              ",CD.year,"\n");
  875.     Cal_YEAR;
  876.    END
  877.   else
  878.    BEGIN
  879.     Cal(0);
  880.     For i:=1 to 9 do
  881.      BEGIN
  882.       j:=Strlen(Str[i])-1;
  883.       While isspace(Str[i][j]) do
  884.        BEGIN                         { cut spaces }
  885.         Str[i][j]:='\0';
  886.         Dec(j);
  887.        END;
  888.       if Strlen(Str[i])>0 then Writeln(Str[i]);
  889.       If CheckBreak then CleanExit("*** break",0);
  890.      END;
  891.     Writeln;
  892.    END;
  893.  
  894.   CleanExit(NIL,0);
  895. END.
  896.  
  897. { /// ------------------------------------------------------------------------ }
  898.  
  899.